| Filename | (eval 1114)[/usr/share/perl5/CGI.pm:932] |
| Statements | Executed 50 statements in 501µs |
| Eval Invoked At | /usr/share/perl5/CGI.pm line 932 |
| Sibling evals | 1, 2, 3, 4 |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 0 | 0 | 0 | 0s | 0s | CGI::header |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package CGI; sub header { | ||||
| 2 | 1 | 6µs | 1 | 3µs | my($self,@p) = self_or_default(@_); # spent 3µs making 1 call to CGI::self_or_default |
| 3 | 1 | 200ns | my(@header); | ||
| 4 | |||||
| 5 | 1 | 4µs | return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; | ||
| 6 | |||||
| 7 | 1 | 73µs | 1 | 65µs | my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = # spent 65µs making 1 call to CGI::Util::rearrange |
| 8 | rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], | ||||
| 9 | 'STATUS',['COOKIE','COOKIES','SET-COOKIE'],'TARGET', | ||||
| 10 | 'EXPIRES','NPH','CHARSET', | ||||
| 11 | 'ATTACHMENT','P3P'],@p); | ||||
| 12 | |||||
| 13 | # Since $cookie and $p3p may be array references, | ||||
| 14 | # we must stringify them before CR escaping is done. | ||||
| 15 | 1 | 100ns | my @cookie; | ||
| 16 | 1 | 700ns | for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) { | ||
| 17 | 1 | 6µs | 1 | 1µs | my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; # spent 1µs making 1 call to UNIVERSAL::isa |
| 18 | 1 | 900ns | push(@cookie,$cs) if defined $cs and $cs ne ''; | ||
| 19 | } | ||||
| 20 | 1 | 100ns | $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY'; | ||
| 21 | |||||
| 22 | # CR escaping for values, per RFC 822 | ||||
| 23 | 1 | 800ns | for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) { | ||
| 24 | 9 | 3µs | if (defined $header) { | ||
| 25 | # From RFC 822: | ||||
| 26 | # Unfolding is accomplished by regarding CRLF immediately | ||||
| 27 | # followed by a LWSP-char as equivalent to the LWSP-char. | ||||
| 28 | 4 | 28µs | 8 | 11µs | $header =~ s/$CRLF(\s)/$1/g; # spent 10µs making 4 calls to CGI::CORE:regcomp, avg 2µs/call
# spent 2µs making 4 calls to CGI::CORE:subst, avg 450ns/call |
| 29 | |||||
| 30 | # All other uses of newlines are invalid input. | ||||
| 31 | 4 | 36µs | 8 | 21µs | if ($header =~ m/$CRLF|\015|\012/) { # spent 17µs making 4 calls to CGI::CORE:regcomp, avg 4µs/call
# spent 4µs making 4 calls to CGI::CORE:match, avg 1µs/call |
| 32 | # shorten very long values in the diagnostic | ||||
| 33 | $header = substr($header,0,72).'...' if (length $header > 72); | ||||
| 34 | die "Invalid header value contains a newline not followed by whitespace: $header"; | ||||
| 35 | } | ||||
| 36 | } | ||||
| 37 | } | ||||
| 38 | |||||
| 39 | 1 | 300ns | $nph ||= $NPH; | ||
| 40 | |||||
| 41 | 1 | 100ns | $type ||= 'text/html' unless defined($type); | ||
| 42 | |||||
| 43 | # sets if $charset is given, gets if not | ||||
| 44 | 1 | 8µs | 1 | 5µs | $charset = $self->charset( $charset ); # spent 5µs making 1 call to CGI::charset |
| 45 | |||||
| 46 | # rearrange() was designed for the HTML portion, so we | ||||
| 47 | # need to fix it up a little. | ||||
| 48 | 1 | 600ns | for (@other) { | ||
| 49 | # Don't use \s because of perl bug 21951 | ||||
| 50 | 1 | 8µs | 1 | 6µs | next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s; # spent 6µs making 1 call to CGI::CORE:match |
| 51 | 1 | 238µs | 4 | 229µs | ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e; # spent 225µs making 1 call to CGI::AUTOLOAD
# spent 2µs making 1 call to CGI::CORE:subst
# spent 2µs making 2 calls to CGI::CORE:substcont, avg 1µs/call |
| 52 | } | ||||
| 53 | |||||
| 54 | 1 | 4µs | 1 | 600ns | $type .= "; charset=$charset" # spent 600ns making 1 call to CGI::CORE:match |
| 55 | if $type ne '' | ||||
| 56 | and $type !~ /\bcharset\b/ | ||||
| 57 | and defined $charset | ||||
| 58 | and $charset ne ''; | ||||
| 59 | |||||
| 60 | # Maybe future compatibility. Maybe not. | ||||
| 61 | 1 | 2µs | my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; | ||
| 62 | 1 | 100ns | push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; | ||
| 63 | 1 | 0s | push(@header,"Server: " . &server_software()) if $nph; | ||
| 64 | |||||
| 65 | 1 | 800ns | push(@header,"Status: $status") if $status; | ||
| 66 | 1 | 0s | push(@header,"Window-Target: $target") if $target; | ||
| 67 | 1 | 100ns | push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p; | ||
| 68 | # push all the cookies -- there may be several | ||||
| 69 | 1 | 200ns | push(@header,map {"Set-Cookie: $_"} @cookie); | ||
| 70 | # if the user indicates an expiration time, then we need | ||||
| 71 | # both an Expires and a Date header (so that the browser is | ||||
| 72 | # uses OUR clock) | ||||
| 73 | 1 | 100ns | push(@header,"Expires: " . expires($expires,'http')) | ||
| 74 | if $expires; | ||||
| 75 | 1 | 100ns | push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; | ||
| 76 | 1 | 73µs | 1 | 75µs | push(@header,"Pragma: no-cache") if $self->cache(); # spent 75µs making 1 call to CGI::AUTOLOAD |
| 77 | 1 | 100ns | push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; | ||
| 78 | 1 | 3µs | push(@header,map {ucfirst $_} @other); | ||
| 79 | 1 | 900ns | push(@header,"Content-Type: $type") if $type ne ''; | ||
| 80 | 1 | 2µs | my $header = join($CRLF,@header)."${CRLF}${CRLF}"; | ||
| 81 | 1 | 300ns | if (($MOD_PERL >= 1) && !$nph) { | ||
| 82 | $self->r->send_cgi_header($header); | ||||
| 83 | return ''; | ||||
| 84 | } | ||||
| 85 | 1 | 2µs | return $header; | ||
| 86 | } | ||||
| 87 | |||||
| 88 | ; |